home *** CD-ROM | disk | FTP | other *** search
/ Power CD-ROM!! 8 / Power CD-ROM 8.iso / prgmming / showiff / iff.pas next >
Encoding:
Pascal/Delphi Source File  |  1994-12-01  |  6.3 KB  |  340 lines
  1. unit IFF;
  2.  
  3. interface
  4.  
  5. uses Objects, S32K;
  6.  
  7. procedure ShowIFF(F: PStream);
  8.  
  9. implementation
  10.  
  11. uses CRT;
  12.  
  13. type BMPHeader = record
  14.                   BW, BH: Word;
  15.                   PX, PY: Integer;
  16.                   NP: Byte;
  17.                   Mask: Byte;
  18.                   Comp: Byte;
  19.                   Flags: Byte;
  20.                   TC: Word;
  21.                   XA, YA: Byte;
  22.                   PW, PH: Word;
  23.                  end;
  24.  
  25.     RGBSet = record
  26.               R: Byte;
  27.               G: Byte;
  28.               B: Byte;
  29.              end;
  30.  
  31.     TRGBPal = Array[0..0] of RGBSet;
  32.     PRGBPal = ^TRGBPal;
  33.  
  34. const Odd: Byte = 0;
  35.  
  36. var BMPHdr: BMPHeader;
  37.     Comment: String;
  38.     Palette: PRGBPal;
  39.     PalCols: Word;
  40.     Mode: LongInt;
  41.  
  42. procedure SwapBytes(var Val: LongInt); assembler;
  43. asm
  44.  LES DI, Val
  45.  mov al,es:[DI]
  46.  xchg es:[DI+3],al
  47.  mov es:[DI], al
  48.  mov al,es:[DI+1]
  49.  xchg al,es:[DI+2]
  50.  mov es:[DI+1],al
  51. end;
  52.  
  53. function ReadBMHD(F: PStream): LongInt;
  54. var Len: LongInt;
  55. begin
  56.  ReadBMHD := -1;
  57.  F^.Read(Len, 4);
  58.  SwapBytes(Len);
  59.  if Len = 20 then
  60.  begin
  61.   F^.Read(BMPHdr, 20);
  62.   with BMPHdr do
  63.   begin
  64.    BW := Swap(BW);
  65.    BH := Swap(BH);
  66.    PX := Swap(PX);
  67.    PY := Swap(PY);
  68.    TC := Swap(TC);
  69.    PW := Swap(PW);
  70.    PH := Swap(PH);
  71.   end;
  72.   ReadBMHD := 24;
  73.  end;
  74. end;
  75.  
  76. function ReadANNO(F: PStream): LongInt;
  77. var Len: LongInt;
  78.     Sam: Char;
  79.     I: Integer;
  80. begin
  81.  F^.Read(Len, 4);
  82.  SwapBytes(Len);
  83.  Comment := '';
  84.  F^.Read(Comment[1], Len - 1);
  85.  Comment[0] := Chr(Len-1);
  86.  F^.Read(Sam, 1);
  87.  Inc(Len, 4);
  88.  ReadANNO := Len;
  89. end;
  90.  
  91. function ReadCMAP(F: PStream): LongInt;
  92. var Len: LongInt;
  93.     Sam: Char;
  94.     I: Integer;
  95.     R, B, G: Byte;
  96.     J: Integer;
  97.     K: Integer;
  98. begin
  99.  F^.Read(Len, 4);
  100.  SwapBytes(Len);
  101.  GetMem(Palette, Len);
  102.  PalCols := Len div 3;
  103.  F^.Read(Palette^, Len);
  104.  asm
  105.   LES DI, Palette
  106.   MOV BX, Word(Len)
  107.   MOV CL, 3
  108.  @@1:
  109.   SHR BYTE PTR ES:[DI], CL
  110.   INC DI
  111.   DEC BX
  112.   JNZ @@1
  113.  end;
  114.  Inc(Len, 4);
  115.  ReadCMAP := Len;
  116.  
  117.  Mode32K;
  118.  for I := 0 to PalCols - 1 do
  119.  begin
  120.   R := Palette^[I].R;
  121.   G := Palette^[I].G;
  122.   B := Palette^[I].B;
  123.   for J := I * 2 to I*2+1 do
  124.    for K := 0 to 10 do
  125.     MemW[SegA000:J*2 + K * 640 * 2] := R * 1024 + G * 32 + B;
  126.  end;
  127.  R := Byte(ReadKey);
  128. end;
  129.  
  130. procedure GetPad(F: PStream);
  131. var S: Byte;
  132. begin
  133.  if Odd = 0 then
  134.   F^.Read(S, 1);
  135.  Odd := 0;
  136. end;
  137.  
  138. function GetByte(F: PStream): Byte;
  139. const Rept: Byte = 0;
  140.       LChr: Byte = 0;
  141.       Litr: Byte = 0;
  142. begin
  143.  Odd := Odd xor 1;
  144.  if BMPHdr.Comp <> 1 then
  145.  begin
  146.   F^.Read(Litr, 1);
  147.   GetByte := Litr;
  148.   exit;
  149.  end;
  150.  if (Rept > 0) then
  151.  begin
  152.   Dec(Rept);
  153.   GetByte := LChr;
  154.   Exit;
  155.  end;
  156.  if Litr > 0 then
  157.  begin
  158.   F^.Read(LChr, 1);
  159.   GetByte := LChr;
  160.   Dec(Litr);
  161.   exit;
  162.  end;
  163.  repeat
  164.   F^.Read(LChr, 1);
  165.  until LChr <> $80;
  166.  if LChr and $80 <> 0 then
  167.  begin
  168.   Rept := Not LChr + 2;
  169.   F^.Read(LChr, 1);
  170.  end else
  171.   Litr := LChr + 1;
  172.  GetByte := GetByte(F);
  173. end;
  174.  
  175. procedure StretchPic;
  176. var I, J: Integer;
  177.     FI, FJ: Integer;
  178.     DI, DJ: Integer;
  179.     R, G, B: Word;
  180.     C: LongInt;
  181.     SX, SY: LongInt;
  182.     RX, RY: Byte;
  183. begin
  184.  if BMPHdr.PH > BMPHdr.BH then
  185.  begin
  186.   I := BMPHdr.PH;
  187.   FI := 0;
  188.   DI := -1;
  189.  end else
  190.  begin
  191.   I := -1;
  192.   FI := BMPHdr.PH - 1;
  193.   DI := 1;
  194.  end;
  195.  repeat
  196.   Inc(I, DI);
  197.   if BMPHdr.PW > BMPHdr.BW then
  198.   begin
  199.    J := BMPHdr.PW;
  200.    FJ := 0;
  201.    DJ := -1;
  202.   end else
  203.   begin
  204.    J := -1;
  205.    FJ := BMPHdr.PW - 1;
  206.    DJ := 1;
  207.   end;
  208.   repeat
  209.    Inc(J, DJ);
  210.    SX := LongInt(BMPHdr.BW) * J;
  211.    SX := SX div (BMPHdr.PW - 1);
  212.    SY := LongInt(BMPHdr.BH) * I;
  213.    SY := SY div (BMPHdr.PH - 1);
  214.    C := LongInt(640*2)*SY + SX * 2;
  215.    if (((C - Page) > $fffe) or ((C - Page) < 0)) then
  216.     SetPage(C);
  217.    R := MemW[SegA000:Word(C)];
  218.    C := LongInt(640*2)*I + J * 2;
  219.    if (((C - Page) > $fffe) or ((C - Page) < 0)) then
  220.     SetPage(C);
  221.    MemW[SegA000:Word(C)] := R;
  222.   until J = FJ;
  223.  until I = FI;
  224. end;
  225.  
  226. function ShowBODY(F: PStream): LongInt;
  227. var Len: LongInt;
  228.     I, J, K, L: Word;
  229.     X: LongInt;
  230.     Sh: Byte;
  231.     S: Byte;
  232.     S1, S2: Word;
  233.     Rd, Gr, Bl: Byte;
  234.     Ov: Word;
  235. begin
  236.  F^.Read(Len, 4);
  237.  SwapBytes(Len);
  238.  Inc(Len, 4);
  239.  Mode32K;
  240.  SetPage(0);
  241.  for I := 0 to BMPHdr.BH - 1 do
  242.  begin
  243.   Rd := 0; Bl := 0; Gr := 0;
  244.   for L := 0 to BMPHdr.NP - 1 do
  245.   begin
  246.    X := LongInt(640*2) * I; Sh := L;
  247.    for J := 0 to ((BMPHdr.BW + 15) div 16) * 2 - 1 do
  248.    begin
  249.     S := GetByte(F);
  250.     for K := 7 downto 0 do
  251.     begin
  252.      if (((X - Page) > $fffe) or ((X - Page) < 0)) then
  253.       SetPage(X);
  254.      MemW[SegA000:Word(X)] := MemW[SegA000:Word(X)]
  255.         or (((S shr K) and 1) shl Sh);
  256.      if L = BMPHdr.NP - 1 then
  257.      begin
  258.       S1 := MemW[SegA000:Word(X)];
  259.       S2 := S1 shr 4; if (Mode and $800 <> 0) then
  260.        S1 := S1 and $f;
  261.       if ((Mode and $800) <> $800) or (S2 = 0) then
  262.        with Palette^[S1] do
  263.        begin
  264.         Rd := R;
  265.         Gr := G;
  266.         Bl := B;
  267.        end else
  268.        case S2 of
  269.         2: Rd := S1 * 2;
  270.         1: Bl := S1 * 2;
  271.         3: Gr := S1 * 2;
  272.        end;
  273.       Ov := Rd * 1024 + Gr * 32 + Bl;
  274.       MemW[SegA000:Word(X)] := Ov;
  275.      end;
  276.      Inc(X, 2);
  277.     end;
  278.    end;
  279.   end;
  280.  end;
  281.  
  282.  StretchPic;
  283.  
  284.  S := Ord(ReadKey);
  285.  ShowBody := Len;
  286. end;
  287.  
  288. function ReadCAMG(F: PStream): LongInt;
  289. var Len: LongInt;
  290. begin
  291.  F^.Read(Len, 4);
  292.  SwapBytes(Len);
  293.  F^.Read(Mode, 4);
  294.  SwapBytes(Mode);
  295.  Inc(Len, 4);
  296.  ReadCAMG := Len;
  297. end;
  298.  
  299. function ReadILBM(F: PStream): LongInt;
  300. var ID: LongInt;
  301.     Len: LongInt;
  302.     Dum: Array[0..7] of byte;
  303. begin
  304.  Len := 0;
  305.  repeat
  306.   F^.Read(ID, 4);
  307.   Inc(Len, 4);
  308.   if ID = $44484D42 then Inc(Len, ReadBMHD(F)) else
  309.   if ID = $4F4E4E41 then Inc(Len, ReadANNO(F)) else
  310.   if ID = $50414D43 then Inc(Len, ReadCMAP(F)) else
  311.   if ID = $474D4143 then Inc(Len, ReadCAMG(F)) else
  312.   if ID = $20495044 then begin F^.Read(Dum, 8); Inc(Len, 8); end else
  313.   if ID = $59444F42 then Inc(Len, ShowBODY(F));
  314.  until ID = 0;
  315.  ReadILBM := Len;
  316. end;
  317.  
  318. procedure ReadData(F:PStream);
  319. var Len: LongInt;
  320.     ID: LongInt;
  321. begin
  322.  F^.Read(Len, 4);
  323.  SwapBytes(Len);
  324.  while (Len > 0) do
  325.  begin
  326.   F^.Read(ID, 4);
  327.   Dec(Len, 4);
  328.   if ID = $4D424C49 then Dec(Len, ReadILBM(F));
  329.  end;
  330. end;
  331.  
  332. procedure ShowIFF(F: PStream);
  333. var ID: LongInt;
  334. begin
  335.  F^.Read(ID, 4);
  336.  if ID = $4D524F46 then
  337.   ReadData(F);
  338. end;
  339.  
  340. end.